home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / tn.lisp < prev    next >
Encoding:
Text File  |  1991-11-25  |  18.4 KB  |  572 lines
  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: tn.lisp,v 1.15 91/11/24 23:47:32 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    This file contains utilities used for creating and manipulating TNs, and
  15. ;;; some other more assorted IR2 utilities.
  16. ;;;
  17. ;;; Written by Rob MacLachlan
  18. ;;;
  19. (in-package 'c)
  20.  
  21. (export '(make-normal-tn make-representation-tn make-wired-tn
  22.       make-restricted-tn environment-live-tn
  23.       environment-debug-live-tn component-live-tn specify-save-tn
  24.       make-constant-tn make-alias-tn make-load-time-constant-tn
  25.       make-n-tns location= tn-value force-tn-to-stack))
  26.  
  27. ;;; The component that is currently being compiled.  TNs are allocated in this
  28. ;;; component.
  29. ;;;
  30. (defvar *compile-component*)
  31.  
  32.  
  33. ;;; Do-Packed-TNs  --  Interface
  34. ;;;
  35. (defmacro do-packed-tns ((tn component &optional result) &body body)
  36.   "Do-Packed-TNs (TN-Var Component [Result]) Declaration* Form*
  37.   Iterate over all packed TNs allocated in Component."
  38.   (let ((n-component (gensym)))
  39.     `(let ((,n-component (component-info ,component)))
  40.        (do ((,tn (ir2-component-normal-tns ,n-component) (tn-next ,tn)))
  41.        ((null ,tn))
  42.      ,@body)
  43.        (do ((,tn (ir2-component-restricted-tns ,n-component) (tn-next ,tn)))
  44.        ((null ,tn))
  45.      ,@body)
  46.        (do ((,tn (ir2-component-wired-tns ,n-component) (tn-next ,tn)))
  47.        ((null ,tn)
  48.         ,result)
  49.      ,@body))))
  50.  
  51.  
  52. ;;; Delete-Unreferenced-TNs  --  Interface
  53. ;;;
  54. ;;;    Remove all TNs with no references from the lists of unpacked TNs.  We
  55. ;;; null out the Offset so that nobody will mistake deleted wired TNs for
  56. ;;; properly packed TNs.  We mark non-deleted alias TNs so that aliased TNs
  57. ;;; aren't considered to be unreferenced.
  58. ;;;
  59. (defun delete-unreferenced-tns (component)
  60.   (let* ((2comp (component-info component))
  61.      (aliases (make-array (1+ (ir2-component-global-tn-counter 2comp))
  62.                   :element-type 'bit :initial-element 0)))
  63.     (labels ((delete-some (getter setter)
  64.            (let ((prev nil))
  65.          (do ((tn (funcall getter 2comp) (tn-next tn)))
  66.              ((null tn))
  67.            (cond
  68.             ((or (used-p tn)
  69.              (and (eq (tn-kind tn) :specified-save)
  70.                   (used-p (tn-save-tn tn))))
  71.              (setq prev tn))
  72.             (t
  73.              (delete-1 tn prev setter))))))
  74.          (used-p (tn)
  75.            (or (tn-reads tn) (tn-writes tn)
  76.            (member (tn-kind tn) '(:component :environment))
  77.            (not (zerop (sbit aliases (tn-number tn))))))
  78.          (delete-1 (tn prev setter)
  79.            (if prev
  80.            (setf (tn-next prev) (tn-next tn))
  81.            (funcall setter (tn-next tn) 2comp))
  82.            (setf (tn-offset tn) nil)
  83.            (case (tn-kind tn)
  84.          (:environment
  85.           (clear-live tn #'ir2-environment-live-tns
  86.                   #'(setf ir2-environment-live-tns)))
  87.          (:debug-environment
  88.           (clear-live tn #'ir2-environment-debug-live-tns
  89.                   #'(setf ir2-environment-debug-live-tns)))))
  90.          (clear-live (tn getter setter)
  91.            (let ((env (environment-info (tn-environment tn))))
  92.          (funcall setter (delete tn (funcall getter env)) env))))
  93.       (declare (inline used-p delete-some delete-1 clear-live))
  94.       (delete-some #'ir2-component-alias-tns
  95.            #'(setf ir2-component-alias-tns))
  96.       (do ((tn (ir2-component-alias-tns 2comp) (tn-next tn)))
  97.       ((null tn))
  98.     (setf (sbit aliases (tn-number (tn-save-tn tn))) 1))
  99.       (delete-some #'ir2-component-normal-tns
  100.            #'(setf ir2-component-normal-tns))
  101.       (delete-some #'ir2-component-restricted-tns
  102.            #'(setf ir2-component-restricted-tns))
  103.       (delete-some #'ir2-component-wired-tns
  104.            #'(setf ir2-component-wired-tns))))
  105.   (undefined-value))
  106.  
  107.  
  108. ;;;; TN Creation:
  109.  
  110. ;;; Make-Normal-TN  --  Interface
  111. ;;;
  112. ;;;    Create a packed TN of the specified primitive-type in the
  113. ;;; *Compile-Component*.  We use the SCs from the primitive type to determine
  114. ;;; which SCs it can be packed in.
  115. ;;;
  116. (defun make-normal-tn (type)
  117.   (declare (type primitive-type type))
  118.   (let* ((component (component-info *compile-component*))
  119.      (res (make-tn (incf (ir2-component-global-tn-counter component))
  120.                :normal type nil)))
  121.     (push-in tn-next res (ir2-component-normal-tns component))
  122.     res))
  123.  
  124.  
  125. ;;; MAKE-REPRESENTATION-TN  --  Interface
  126. ;;;
  127. ;;;    Create a normal packed TN with representation indicated by SCN.
  128. ;;;
  129. (defun make-representation-tn (ptype scn)
  130.   (declare (type primitive-type ptype) (type sc-number scn))
  131.   (let* ((component (component-info *compile-component*))
  132.      (res (make-tn (incf (ir2-component-global-tn-counter component))
  133.                :normal ptype
  134.                (svref (backend-sc-numbers *backend*) scn))))
  135.     (push-in tn-next res (ir2-component-normal-tns component))
  136.     res))
  137.  
  138.  
  139. ;;; Make-Wired-TN  --  Interface
  140. ;;;
  141. ;;;    Create a TN wired to a particular location in an SC.  We set the Offset
  142. ;;; and FSC to record where it goes, and then put it on the current component's
  143. ;;; Wired-TNs list.  Ptype is the TN's primitive-type, which may be NIL in VOP
  144. ;;; temporaries.
  145. ;;;
  146. (defun make-wired-tn (ptype scn offset)
  147.   (declare (type (or primitive-type null) ptype)
  148.        (type sc-number scn) (type unsigned-byte offset))
  149.   (let* ((component (component-info *compile-component*))
  150.      (res (make-tn (incf (ir2-component-global-tn-counter component))
  151.                :normal ptype
  152.                (svref (backend-sc-numbers *backend*) scn))))
  153.     (setf (tn-offset res) offset)
  154.     (push-in tn-next res (ir2-component-wired-tns component))
  155.     res))
  156.  
  157.  
  158. ;;; Make-Restricted-TN  --  Interface
  159. ;;;
  160. ;;;    Create a packed TN restricted to the SC with number SCN.  Ptype is as
  161. ;;; for MAKE-WIRED-TN.
  162. ;;;
  163. (defun make-restricted-tn (ptype scn)
  164.   (declare (type (or primitive-type null) ptype) (type sc-number scn))
  165.   (let* ((component (component-info *compile-component*))
  166.      (res (make-tn (incf (ir2-component-global-tn-counter component))
  167.                :normal ptype
  168.                (svref (backend-sc-numbers *backend*) scn))))
  169.     (push-in tn-next res (ir2-component-restricted-tns component))
  170.     res))
  171.  
  172.  
  173. ;;; ENVIRONMENT-LIVE-TN, ENVIRONMENT-DEBUG-LIVE-TN  --  Interface
  174. ;;;
  175. ;;;    Make TN be live throughout environment.  Return TN.  In the DEBUG case,
  176. ;;; the TN is treated normally in blocks in the environment which reference the
  177. ;;; TN, allowing targeting to/from the TN.  This results in move efficient
  178. ;;; code, but may result in the TN sometimes not being live when you want it.
  179. ;;;
  180. (defun environment-live-tn (tn env)
  181.   (declare (type tn tn) (type environment env))
  182.   (assert (eq (tn-kind tn) :normal))
  183.   (setf (tn-kind tn) :environment)
  184.   (setf (tn-environment tn) env)
  185.   (push tn (ir2-environment-live-tns (environment-info env)))
  186.   tn)
  187. ;;;
  188. (defun environment-debug-live-tn (tn env)
  189.   (declare (type tn tn) (type environment env))
  190.   (assert (eq (tn-kind tn) :normal))
  191.   (setf (tn-kind tn) :debug-environment)
  192.   (setf (tn-environment tn) env)
  193.   (push tn (ir2-environment-debug-live-tns (environment-info env)))
  194.   tn)
  195.  
  196.  
  197. ;;; Component-Live-TN  --  Interface
  198. ;;;
  199. ;;;    Make TN be live throughout the current component.  Return TN.
  200. ;;;
  201. (defun component-live-tn (tn)
  202.   (declare (type tn tn))
  203.   (assert (eq (tn-kind tn) :normal))
  204.   (setf (tn-kind tn) :component)
  205.   (push tn (ir2-component-component-tns (component-info *compile-component*)))
  206.   tn)
  207.  
  208.  
  209. ;;; SPECIFY-SAVE-TN  --  Interface
  210. ;;;
  211. ;;;    Specify that Save be used as the save location for TN.  TN is returned. 
  212. ;;;
  213. (defun specify-save-tn (tn save)
  214.   (declare (type tn tn save))
  215.   (assert (eq (tn-kind save) :normal))
  216.   (assert (and (not (tn-save-tn tn)) (not (tn-save-tn save))))
  217.   (setf (tn-kind save) :specified-save)
  218.   (setf (tn-save-tn tn) save)
  219.   (setf (tn-save-tn save) tn)
  220.   (push save
  221.     (ir2-component-specified-save-tns
  222.      (component-info *compile-component*)))
  223.   tn)
  224.  
  225.  
  226. ;;; Make-Constant-TN  --  Interface
  227. ;;;
  228. ;;;    Create a constant TN.  The implementation dependent
  229. ;;; Immediate-Constant-SC function is used to determine whether the constant
  230. ;;; has an immediate representation.
  231. ;;;
  232. (defun make-constant-tn (constant)
  233.   (declare (type constant constant))
  234.   (let* ((component (component-info *compile-component*))
  235.      (immed (immediate-constant-sc (constant-value constant)))
  236.      (sc (svref (backend-sc-numbers *backend*)
  237.             (or immed (sc-number-or-lose 'constant *backend*))))
  238.      (res (make-tn 0 :constant (primitive-type (leaf-type constant)) sc)))
  239.     (unless immed
  240.       (let ((constants (ir2-component-constants component)))
  241.     (setf (tn-offset res) (fill-pointer constants))
  242.     (vector-push-extend constant constants)))
  243.     (push-in tn-next res (ir2-component-constant-tns component))
  244.     (setf (tn-leaf res) constant)
  245.     res))
  246.  
  247.  
  248. ;;; MAKE-LOAD-TIME-VALUE-TN  --  interface.
  249. ;;;
  250. (defun make-load-time-value-tn (handle type)
  251.   (let* ((component (component-info *compile-component*))
  252.      (sc (svref (backend-sc-numbers *backend*)
  253.             (sc-number-or-lose 'constant *backend*)))
  254.      (res (make-tn 0 :constant (primitive-type type) sc))
  255.      (constants (ir2-component-constants component)))
  256.     (setf (tn-offset res) (fill-pointer constants))
  257.     (vector-push-extend (cons :load-time-value handle) constants)
  258.     (push-in tn-next res (ir2-component-constant-tns component))
  259.     res))
  260.  
  261. ;;; MAKE-ALIAS-TN  --  Interface
  262. ;;;
  263. ;;;    Make a TN that aliases TN for use in local call argument passing.
  264. ;;;
  265. (defun make-alias-tn (tn)
  266.   (declare (type tn tn))
  267.   (let* ((component (component-info *compile-component*))
  268.      (res (make-tn (incf (ir2-component-global-tn-counter component))
  269.                :alias (tn-primitive-type tn) nil)))
  270.     (setf (tn-save-tn res) tn)
  271.     (push-in tn-next res
  272.          (ir2-component-alias-tns component))
  273.     res))
  274.  
  275.  
  276. ;;; Make-Load-Time-Constant-TN  --  Internal
  277. ;;;
  278. ;;;    Return a load-time constant TN with the specified Kind and Info.  If the
  279. ;;; desired Constants entry already exists, then reuse it, otherwise allocate a
  280. ;;; new load-time constant slot.
  281. ;;;
  282. (defun make-load-time-constant-tn (kind info)
  283.   (declare (type keyword kind))
  284.   (let* ((component (component-info *compile-component*))
  285.      (res (make-tn 0 :constant (backend-any-primitive-type *backend*)
  286.                (svref (backend-sc-numbers *backend*)
  287.                   (sc-number-or-lose 'constant *backend*))))
  288.      (constants (ir2-component-constants component)))
  289.  
  290.     (do ((i 0 (1+ i)))
  291.     ((= i (length constants))
  292.      (setf (tn-offset res) i)
  293.      (vector-push-extend (cons kind info) constants))
  294.       (let ((entry (aref constants i)))
  295.     (when (and (consp entry)
  296.            (eq (car entry) kind)
  297.            (eq (cdr entry) info))
  298.       (setf (tn-offset res) i))))
  299.  
  300.     (push-in tn-next res (ir2-component-constant-tns component))
  301.     res))  
  302.  
  303.  
  304. ;;;; TN referencing:
  305.  
  306. ;;; Reference-TN  --  Interface
  307. ;;;
  308. ;;;    Make a TN-Ref that references TN and return it.  Write-P should be true
  309. ;;; if this is a write reference, otherwise false.  All we do other than
  310. ;;; calling the constructor is add the reference to the TN's references.
  311. ;;;
  312. (defun reference-tn (tn write-p)
  313.   (declare (type tn tn) (type boolean write-p))
  314.   (let ((res (make-tn-ref tn write-p)))
  315.     (if write-p
  316.     (push-in tn-ref-next res (tn-writes tn))
  317.     (push-in tn-ref-next res (tn-reads tn)))
  318.     res))
  319.  
  320.  
  321. ;;; Reference-TN-List  --  Interface
  322. ;;;
  323. ;;;    Make TN-Refs to reference each TN in TNs, linked together by
  324. ;;; TN-Ref-Across.  Write-P is the Write-P value for the refs.  More is 
  325. ;;; stuck in the TN-Ref-Across of the ref for the last TN, or returned as the
  326. ;;; result if there are no TNs.
  327. ;;;
  328. (defun reference-tn-list (tns write-p &optional more)
  329.   (declare (list tns) (type boolean write-p) (type (or tn-ref null) more))
  330.   (if tns
  331.       (let* ((first (reference-tn (first tns) write-p))
  332.          (prev first))
  333.     (dolist (tn (rest tns))
  334.       (let ((res (reference-tn tn write-p)))
  335.         (setf (tn-ref-across prev) res)
  336.         (setq prev res)))
  337.     (setf (tn-ref-across prev) more)
  338.     first)
  339.       more))
  340.  
  341.  
  342. ;;; Delete-TN-Ref  --  Interface
  343. ;;;
  344. ;;;    Remove Ref from the references for its associated TN.
  345. ;;;
  346. (defun delete-tn-ref (ref)
  347.   (declare (type tn-ref ref))
  348.   (if (tn-ref-write-p ref)
  349.       (deletef-in tn-ref-next (tn-writes (tn-ref-tn ref)) ref)
  350.       (deletef-in tn-ref-next (tn-reads (tn-ref-tn ref)) ref))
  351.   (undefined-value))
  352.  
  353.  
  354. ;;; Change-TN-Ref-TN  --  Interface
  355. ;;;
  356. ;;;    Do stuff to change the TN referenced by Ref.  We remove Ref from it's
  357. ;;; old TN's refs, add ref to TN's refs, and set the TN-Ref-TN.
  358. ;;;
  359. (defun change-tn-ref-tn (ref tn)
  360.   (declare (type tn-ref ref) (type tn tn))
  361.   (delete-tn-ref ref)
  362.   (setf (tn-ref-tn ref) tn)
  363.   (if (tn-ref-write-p ref)
  364.       (push-in tn-ref-next ref (tn-writes tn))
  365.       (push-in tn-ref-next ref (tn-reads tn)))
  366.   (undefined-value))
  367.  
  368.  
  369. ;;;; Random utilities:
  370.  
  371.  
  372. ;;; Emit-Move-Template  --  Internal
  373. ;;;
  374. ;;;    Emit a move-like template determined at run-time, with X as the argument
  375. ;;; and Y as the result.  Useful for move, coerce and type-check templates.  If
  376. ;;; supplied, then insert before VOP, otherwise insert at then end of the
  377. ;;; block.  Returns the last VOP inserted.
  378. ;;;
  379. (defun emit-move-template (node block template x y &optional before)
  380.   (declare (type node node) (type ir2-block block)
  381.        (type template template) (type tn x y))
  382.   (let ((arg (reference-tn x nil))
  383.     (result (reference-tn y t)))
  384.     (multiple-value-bind
  385.     (first last)
  386.     (funcall (template-emit-function template) node block template arg
  387.          result)
  388.       (insert-vop-sequence first last block before)
  389.       last)))
  390.  
  391.  
  392. ;;; EMIT-LOAD-TEMPLATE  --  Internal
  393. ;;;
  394. ;;;    Like EMIT-MOVE-TEMPLATE, except that we pass in Info args too.
  395. ;;;
  396. (defun emit-load-template (node block template x y info &optional before)
  397.   (declare (type node node) (type ir2-block block)
  398.        (type template template) (type tn x y))
  399.   (let ((arg (reference-tn x nil))
  400.     (result (reference-tn y t)))
  401.     (multiple-value-bind
  402.     (first last)
  403.     (funcall (template-emit-function template) node block template arg
  404.          result info)
  405.       (insert-vop-sequence first last block before)
  406.       last)))
  407.  
  408.  
  409. ;;; EMIT-MOVE-ARG-TEMPLATE  --  Internal
  410. ;;;
  411. ;;;    Like EMIT-MOVE-TEMPLATE, except that the VOP takes two args.
  412. ;;;
  413. (defun emit-move-arg-template (node block template x f y &optional before)
  414.   (declare (type node node) (type ir2-block block)
  415.        (type template template) (type tn x f y))
  416.   (let ((x-ref (reference-tn x nil))
  417.     (f-ref (reference-tn f nil))
  418.     (y-ref (reference-tn y t)))
  419.     (setf (tn-ref-across x-ref) f-ref)
  420.     (multiple-value-bind
  421.     (first last)
  422.     (funcall (template-emit-function template) node block template x-ref
  423.          y-ref)
  424.       (insert-vop-sequence first last block before)
  425.       last)))
  426.  
  427.  
  428. ;;; EMIT-CONTEXT-TEMPLATE  --  Internal
  429. ;;;
  430. ;;;    Like EMIT-MOVE-TEMPLATE, except that the VOP takes no args.
  431. ;;;
  432. (defun emit-context-template (node block template y &optional before)
  433.   (declare (type node node) (type ir2-block block)
  434.        (type template template) (type tn y))
  435.   (let ((y-ref (reference-tn y t)))
  436.     (multiple-value-bind
  437.     (first last)
  438.     (funcall (template-emit-function template) node block template nil
  439.          y-ref)
  440.       (insert-vop-sequence first last block before)
  441.       last)))
  442.  
  443.  
  444. ;;; Block-Label  --  Interface
  445. ;;;
  446. ;;;    Return the label marking the start of Block, assigning one if necessary.
  447. ;;;
  448. (defun block-label (block)
  449.   (declare (type cblock block))
  450.   (let ((2block (block-info block)))
  451.     (or (ir2-block-%label 2block)
  452.     (setf (ir2-block-%label 2block) (gen-label)))))
  453.  
  454.  
  455. ;;; Drop-Thru-P  --  Interface
  456. ;;;
  457. ;;;    Return true if Block is emitted immediately after the block ended by
  458. ;;; Node.
  459. ;;;
  460. (defun drop-thru-p (node block)
  461.   (declare (type node node) (type cblock block))
  462.   (let ((next-block (ir2-block-next (block-info (node-block node)))))
  463.     (assert (eq node (block-last (node-block node))))
  464.     (eq next-block (block-info block))))
  465.  
  466.  
  467. ;;; Insert-VOP-Sequence  --  Interface
  468. ;;;
  469. ;;;    Link a list of VOPs from First to Last into Block, Before the specified
  470. ;;; VOP.  If Before is NIL, insert at the end.
  471. ;;;
  472. (defun insert-vop-sequence (first last block before)
  473.   (declare (type vop first last) (type ir2-block block)
  474.        (type (or vop null) before))
  475.   (if before
  476.       (let ((prev (vop-prev before)))
  477.     (setf (vop-prev first) prev)
  478.     (if prev
  479.         (setf (vop-next prev) first)
  480.         (setf (ir2-block-start-vop block) first))
  481.     (setf (vop-next last) before)
  482.     (setf (vop-prev before) last))
  483.       (let ((current (ir2-block-last-vop block)))
  484.     (setf (vop-prev first) current)
  485.     (setf (ir2-block-last-vop block) last)
  486.     (if current
  487.         (setf (vop-next current) first)
  488.         (setf (ir2-block-start-vop block) first))))
  489.   (undefined-value))
  490.  
  491.  
  492. ;;; DELETE-VOP  --  Interface
  493. ;;;
  494. ;;;    Delete all of the TN-Refs associated with VOP and remove VOP from the
  495. ;;; IR2.
  496. ;;;
  497. (defun delete-vop (vop)
  498.   (declare (type vop vop))
  499.   (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
  500.       ((null ref))
  501.     (delete-tn-ref ref))
  502.  
  503.   (let ((prev (vop-prev vop))
  504.     (next (vop-next vop))
  505.     (block (vop-block vop)))
  506.     (if prev
  507.     (setf (vop-next prev) next)
  508.     (setf (ir2-block-start-vop block) next))
  509.     (if next
  510.     (setf (vop-prev next) prev)
  511.     (setf (ir2-block-last-vop block) prev)))
  512.  
  513.   (undefined-value))
  514.  
  515.  
  516. ;;; Make-N-TNs  --  Interface
  517. ;;;
  518. ;;;    Return a list of N normal TNs of the specified primitive type.
  519. ;;;
  520. (defun make-n-tns (n ptype)
  521.   (declare (type unsigned-byte n) (type primitive-type ptype))
  522.   (collect ((res))
  523.     (dotimes (i n)
  524.       (res (make-normal-tn ptype)))
  525.     (res)))
  526.  
  527.  
  528. ;;; Location=  --  Interface
  529. ;;;
  530. ;;;    Return true if X and Y are packed in the same location, false otherwise.
  531. ;;; This is false if either operand is constant.
  532. ;;;
  533. (defun location= (x y)
  534.   (declare (type tn x y))
  535.   (and (eq (sc-sb (tn-sc x)) (sc-sb (tn-sc y)))
  536.        (eql (tn-offset x) (tn-offset y))
  537.        (not (or (eq (tn-kind x) :constant)
  538.         (eq (tn-kind y) :constant)))))
  539.  
  540.  
  541. ;;; TN-Value  --  Interface
  542. ;;;
  543. ;;;    Return the value of an immediate constant TN.
  544. ;;;
  545. (defun tn-value (tn)
  546.   (declare (type tn tn))
  547.   (assert (member (tn-kind tn) '(:constant :cached-constant)))
  548.   (constant-value (tn-leaf tn)))
  549.  
  550.  
  551. ;;; Force-TN-To-Stack  --  Interface
  552. ;;;
  553. ;;;    Force TN to be allocated in a SC that doesn't need to be saved: an
  554. ;;; unbounded non-save-p SC.  We don't actually make it a real "restricted" TN,
  555. ;;; but since we change the SC to an unbounded one, we should always succeed in
  556. ;;; packing it in that SC.
  557. ;;;
  558. (defun force-tn-to-stack (tn)
  559.   (declare (type tn tn))
  560.   (let ((sc (tn-sc tn)))
  561.     (unless (and (not (sc-save-p sc))
  562.          (eq (sb-kind (sc-sb sc)) :unbounded))
  563.       (dolist (alt (sc-alternate-scs sc)
  564.            (error "SC ~S has no :unbounded :save-p NIL alternate SC."
  565.               (sc-name sc)))
  566.     (when (and (not (sc-save-p alt))
  567.            (eq (sb-kind (sc-sb alt)) :unbounded))
  568.       (setf (tn-sc tn) alt)
  569.       (return)))))
  570.   (undefined-value))
  571.  
  572.